home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 1
/
Cream of the Crop 1.iso
/
PROGRAM
/
DDJ0992.ARJ
/
CLISP.C
< prev
next >
Wrap
Text File
|
1992-07-10
|
19KB
|
389 lines
/* File C-LISP.C List of C-LISP functions.
Modified by Douglas Chubb, 1991-92. */
/** Lisp-Style Library for C (Main File of User Functions) **/
/* Include Files */
#include <stdlib.h>
#include <string.h>
#include <stdio.h>
#include <stdarg.h>
#include "lisp-header.h"
#include "int-lisp-syms.h"
/** Functions **/
/* error -- write string (args like 'printf') to 'stdout' and exit */
void error (char *fstr, ...)
{
va_list ap;
va_start (ap, fstr);
fprintf(stderr, "error: ");
vfprintf (stderr, fstr, ap);
fprintf (stderr, "\n");
va_end (ap);
exit (1);
}
/***********************************************************/
/** LISP List Constructors: CONS, LAST_PUT, LIST & APPEND **/
/* FIRST_PUT -- add an Object to the front of a list (LISP "CONS") */
Object first_put (Object item, Object list)
{
Object new_list;
new_list = (Object) safe_malloc (sizeof (Object_Type) + sizeof (Pair));
type (new_list) = PAIR;
pair (new_list) -> car = item;
pair (new_list) -> cdr = list;
return (new_list);
}
/* LAST_PUT -- add an Object to the end of a list (Destructive!) */
Object last_put (Object item, Object list)
{
Object old_list, new_list;
new_list = first_put (item, NULL);
if (list == NULL)
return (new_list);
else
{
old_list = list;
while (but_first (list) != NULL)
list = but_first (list);
pair (list) -> cdr = new_list;
return (old_list);
}
}
/* LAST -- return the list of last Object in list 'lst' */
Object last (Object lst)
{
Object foo;
if(!is_list(lst))
error("\nlast: arg not a list");
if(lst == NULL)
return(NULL);
while(lst != NULL)
{
foo = first(lst);
lst = but_first(lst);
}
return(list(foo, T_EOF));
}
/* LIST -- return a new list of given arguments (last arg must be T_EOF) */
Object list (Object item, ...)
{
va_list ap;
Object result;
result = NULL;
va_start (ap, item);
while (item != T_EOF)
{
result = last_put (item, result);
item = va_arg (ap, Object);
}
va_end (ap);
return (result);
}
/* APPEND -- concatenates two lists non-destructively LISP equivalent */
Object append (Object list1, Object list2)
{
Object rlist1;
if (list1 == NULL)
return(list2);
else
if (list2 == NULL)
return(list1);
else
{
rlist1 = reverse(list1);
while(rlist1 != NULL)
{
list2 = first_put(first(rlist1), list2);
rlist1 = but_first(rlist1);
}
}
return(list2);
}
/* NCONC -- concatenate two lists (destructive (!) LISP equivalent) */
Object nconc (Object list_1, Object list_2)
{
Object list;
if (list_1 == NULL)
return (list_2);
else
if (list_2 == NULL)
return (list_1);
else
{
list = list_1;
while (but_first (list) != NULL)
list = but_first (list);
pair (list) -> cdr = list_2;
return (list_1);
}
}
/* LISP_UNION -- takes two lists and returns a new list containing everything
that is an element of either of the lists (LISP 'UNION' Predicate) */
Object lisp_union (Object list1, Object list2)
{
return (remove_duplicates (append (list1, list2)));
}
/* GET_PROP -- 'get' the property associated with 'indicator' on symbol */
Object get_prop (Object sym, char *str)
{
Object prop_list, ind_list;
Object indic2 = make_string(str);
prop_list = symbol(sym)->plist;
while (prop_list != NULL)
{
ind_list = first (prop_list);
prop_list = but_first (prop_list);
if (strcmp (string (indic2), string (first (ind_list))) == 0)
return (first (but_first (ind_list)));
}
return (NULL);
}
/* PUT_PROP -- 'put' indicator-property on symbol's plist */
void put_prop (Object sym, char *str, Object property)
{
Object prop_list, ind_list, p2;
Object indic2 = make_string(str);
/* add "structure-changed" bit if 'sym' marked for protection */
if(type(sym) > 7)
type(sym) = '\140' | ntype(sym);
prop_list = symbol(sym)->plist;
free_structure(prop_list);
if (prop_list != NULL)
{
p2 = NULL;
while (prop_list != NULL)
{
ind_list = first (prop_list);
prop_list = but_first(prop_list);
if (strcmp (string (indic2), string (first (ind_list))) != 0)
p2 = first_put(ind_list, p2);
else /* remove protect bit for ind_list prop dat for g.c. */
free_structure(ind_list);
}
p2 = first_put (list (indic2, property, T_EOF), p2);
symbol(sym)->plist = p2;
}
else
symbol(sym)->plist = first_put(list (indic2, property, T_EOF), prop_list);
}
/* FREE_STRUCTURE -- recursively removes protection bit to free list structure
for garbage collection. Protected symbols remain protected. */
void free_structure (Object obj)
{
if(obj == NULL || type(obj) <= 7 || ntype(obj) == SYMBOL)
return;
else
switch (ntype(obj))
{
case SYMBOL:
return;
case STRING:
case INTEGER:
case FUNCTION:
break;
case PAIR:
type(obj) = ntype(obj); /* remove protect bit */
free_structure (first(obj));
free_structure (but_first(obj));
break;
default:
error ("free_structure: not standard object");
break;
}
type(obj) = ntype(obj);
}
/* REMPROP -- 'remove' indicator-property from symbol's plist */
void remprop (Object sym, char *str)
{
Object foof, foo;
Object plist = symbol(sym)->plist;
Object indic = make_string(str);
/* add "structure-changed" bit if 'sym' marked for protection */
if(type(sym) > 7)
type(sym) = '\140' | ntype(sym);
free_structure(plist);
foo = NULL;
while(plist != NULL)
{
foof = first(plist);
plist = but_first(plist);
if(strcmp(string(indic), string(first(foof))) != 0)
foo = first_put(foof, foo);
else
free_structure(foof);
/* remove protect bit from ind_list prop data for g.c. */
}
symbol(sym)->plist = foo;
}
/* Lisp Variable for Gensym Symbols */
int gensym_number = 0;
/* GENSYM -- make new interred lisp symbol. Add one to global gensym counter */
Object gensym (char *ppp)
{
Object fname;
char sname[32];
gensym_number += 1;
sprintf(sname, "%s-%d", ppp, gensym_number);
fname = make_symbol(sname);
symbol(fname)->value = NULL;
return(fname);
}
/* MAKE_INDIC make-indicator for get_prop and put_prop functions */
Object make_indic (char *str)
{
return (make_string (str));
}
/* MAKE_PROP symbol for get_prop and put_prop functions */
Object make_prop (char *str)
{
return (make_symbol (str));
}
/********************************************************/
/** LISP List Modifiers **/
/* REVERSE -- return a new list in reverse order (LISP equivalent) */
Object reverse (Object list1)
{
Object new_list = NULL;
while (list1 != NULL)
{
new_list = first_put (first (list1), new_list);
list1 = but_first (list1);
}
return (new_list);
}
/* FLATTEN -- return the leaves of a tree (atoms of nested lists) */
Object flatten (Object obj)
{
if (is_null (obj))
return (first_put (NULL, NULL));
else if (is_atom (obj))
return (list (obj, NULL));
else if (is_null (but_first (obj)))
return (flatten (first (obj)));
else
return (append (flatten (first (obj)), flatten (but_first (obj)) ));
}
/* FLATTEN_NO_NILS -- 'flatten' a tree, discarding NULL atoms */
Object flatten_no_nils (Object obj)
{
if (is_null (obj))
return (NULL);
else if (is_atom (obj))
return (list (obj, NULL));
else
return (append (flatten_no_nils (first (obj)),
flatten_no_nils (but_first (obj)) ));
}
/*****************************************************/
/** LISP MAPPING FUNCTIONS: MAPC, MAPCAR **/
/* MAPC -- apply a function 'f' to each element of a list */
void mapc (Function_1 f, Object list)
{
while (list != NULL)
{
(*f)(first (list));
list = but_first (list);
}
}
/* MAPCAR -- apply a function 'f' to each element of a list, put results in list */
Object mapcar (Function_1 f, Object list)
{
Object output = NULL;
while (list != NULL)
{
output = first_put ((*f) (first (list)), output);
list = but_first (list);
}
return (reverse (output));
}
/* MAPL -- apply a function 'f' to successive 'cdr's' of a list */
void mapl (Function_1 f, Object arg_list)
{
while (arg_list != NULL)
{
(*f)(arg_list);
arg_list = but_first(arg_list);
}
}
/* MAP_NO_NILS -- like 'mapc', but collect only non-NULL results */
Object map_no_nils (Function_1 f, Object list)
{
Object result;
Object output;
output = NULL;
while (list != NULL)
{
result = (*f)(first (list));
if (result != NULL)
output = first_put (result, output);
list = but_first (list);
}
return (reverse (output));
}
/*****************************************************/
/** LISP List Selectors **/
/* NTH -- return nth element of a list or NULL (LISP equivalent) */
Object nth (Object list, int n)
{
while ((list != NULL) && (n > 0))
{
list = but_first (list);
n--;
}
if (list != NULL)
return (first (list));
else
return (NULL);
}
/* ASSOC -- association-list lookup returns PAIR whose 'first' matches key */
Object assoc (Object key, Object a_list)
{
Object pair;
while (a_list != NULL)
{
pair = first (a_list);
if (first (pair) == key)
return (pair);
else
a_list = but_first (a_list);
}
return (NULL);
}
/* pop_f -- pop an object off of a (list-based) stack: 'pop' macro helper */
Object pop_f (Object *location)
{
Object item;
item = first (*location);
*location = but_first (*location);
return (item);
}
/****************************************************/
/** LISP LIST PROPERTIES **/
/* LENGTH -- return the integer length of a list (LISP equivalent) */
int length (Object list)
{
int n;
n = 0;
while (list != NULL)
{
list = but_first (list);
n++;
}
return (n);
}
/* IS_MEMBER -- T if 'obj' is identical to element of 'list', else NULL */
Object is_member (Object obj, Object list)
{ while (list != NULL)
{
if (lisp_equal((first (list)), obj))
return (T);
else
list = but_first (list);
}
return (NULL); }/* MEMBER -- if 'obj' is identical to an element of 'list', return list from that element in list, else return NULL (LISP EQUAL equivalent). */Object member (Object obj, Object list) { while (list != NULL) { if (lisp_equal((first(list)), obj)) return (list); else list = but_first (list); } return (NULL); }/* LISP_EQUAL -- returns T iff Obj1 is 'equal in LISP sense' to Obj2, else return NULL */Object lisp_equal (Object obj1, Object obj2) { if((is_atom (obj1)) && (is_atom (obj2))) { if(obj1 == obj2) return(T); else if(ntype(obj1) == ntype(obj2) && ntype(obj1) == INTEGER && integer(obj1) == integer(obj2)) return(T); else return (NULL); } else if ((is_atom (obj1)) && (is_list (obj2))) return (NULL); else if ((is_list (obj1)) && (is_atom (obj2))) return (NULL); else { if(lisp_equal((first (obj1)),(first(obj2))) && lisp_equal((but_first(obj1)),(but_first(obj2)))) return(T); else return(NULL); } }/* INDEX -- return index of first occurence of 'element' in 'list' */int index (Object element, Object list) { int n; n = 0; while ((list != NULL) && (first (list) != element)) { list = but_first (list); n++; } if (list != NULL) return (n); else return (-1); } /* SET_DIFFERENCE -- returns a list of elements in 'list1' that do not appear in 'list2' */ Object set_difference (Object list1, Object list2) { Object sdl = NULL; if(list2 == NULL || list1 == NULL) return (reverse (list1)); while (list1 != NULL) { if(is_member ((first(list1)), list2)) list1 = but_first (list1); else { sdl = first_put ((first (list1)), sdl); list1 = but_first (list1); } } return(sdl); }/* INTERSECTION -- returns list of elements common to both lst1 and lst2 */Object intersection (Object lst1, Object lst2) { Object common = NULL; if(!is_list(lst1) || !is_list(lst2)) error("\nintersection: arg not a list"); if(is_null(lst1) || is_null(lst2)) return(NULL); else { while(lst1 != NULL) { if(is_member(first(lst1), lst2)) common = first_put(first(lst1), common); else ; lst1 = but_first(lst1); } } return(common); }/* REMOVE_DUPLICATES -- remove duplicate lisp structures in list (uses LISP EQUAL) */Object remove_duplicates (Object obj) { Object nodups = NULL; while (obj != NULL) { if (is_member (first(obj), but_first(obj))) obj = but_first(obj); else { nodups = first_put(first(obj), nodups); obj = but_first(obj); } } return(nodups); }/* REMOVE_ITEM -- remove 'item' from 'sequence' list (LISP "REMOVE" predicate) */Object remove_item (Object item, Object sequence) { Object pp, nitem = NULL; if(lisp_equal(item, sequence)) return(NULL); while(sequence != NULL) { pp = first(sequence); sequence = but_first(sequence); if(lisp_equal(item, pp) ) ; else nitem = first_put(pp, nitem); } return(reverse(nitem)); } /*******************************************************//** LISP OBJECT CONSTRUCTORS **//* MAKE_C_STRING -- return a new copy of argument string in free memory */char *make_c_string (char *str) { char *new_string; new_string = (char *) safe_malloc (strlen (str) + 1); strcpy (new_string, str); return (new_string); }/* MAKE_SYMBOL -- return a new symbol of given name (no table lookup) */Object make_symbol (char *name) { Object new_symbol; new_symbol = (Object) safe_malloc (sizeof (Object_Type) + sizeof (Symbol_Entry) ); type (new_symbol) = SYMBOL; symbol (new_symbol) -> print_name = make_c_string (name); symbol (new_symbol) -> value = _UNDEFINED; symbol (new_symbol) -> plist = NULL; return (new_symbol); }/* MAKE_STRING -- return a new STRING Object with value of given string */Object make_string (char *s) { Object new_string; new_string = (Object) safe_malloc (sizeof (Object_Type) + strlen (s) + 1); type (new_string) = STRING; strcpy (string (new_string), s); return (new_string); }/* MAKE_INTEGER -- return a new INTEGER Object of specified value */Object make_integer (int n) { Object new_integer; new_integer = (Object) safe_malloc (sizeof (Object_Type) + sizeof (int) ); type (new_integer) = INTEGER; integer (new_integer) = n; return (new_integer); }/* MAKE_FUNCTION -- return a new FUNCTION Object of specified value */Object make_function (Function f) { Object new_function; new_function = (Object) safe_malloc (sizeof (Object_Type) + sizeof (Function) ); type(new_function) = FUNCTION; function (new_function) = f; return (new_function); }/************************************************************//** Symbolic Output **//* WRITE_SPACES -- write 'n' spaces to 'stdout' */void write_spaces (int n) { int i; for (i = 0; i < n; i++) putchar (SPACE); }/* write_c_string -- write standard C string with double-quotes and escapes */void write_c_string (char *s) { putchar (DOUBLE_QUOTE); while (*s != EOS) { switch (*s) { case NEWLINE: putchar (BACKSLASH); putchar ('n'); break; case TAB: putchar (BACKSLASH); putchar ('t'); break; case FORMFEED: putchar (BACKSLASH); putchar ('f'); break; case BACKSLASH: putchar (BACKSLASH); putchar (BACKSLASH); break; case DOUBLE_QUOTE: putchar (BACKSLASH); putchar (DOUBLE_QUOTE); break; default: putchar (*s); break; } s++; } putchar (DOUBLE_QUOTE); }/* WRITE_SYMBOL -- write printed representation of SYMBOL Object */void write_symbol (Object obj) { if(type(obj) > 7) printf("%s", string(get_prop(obj, "pn"))); else printf ("%s", symbol(obj) -> print_name); } /* write_string -- write printed representation of STRING Object */void write_string (Object obj) { write_c_string (string (obj)); }/* pp_object -- pretty-print an Object starting at 'col', output at 'hpos' */void pp_object (Object obj, int col, int hpos) { int i; write_spaces (col - hpos); hpos = col; if (obj == NULL) printf ("()"); else switch (ntype (obj)) { case SYMBOL: write_symbol (obj); break; case STRING: write_string (obj); break; case INTEGER: printf ("%d", integer (obj)); break; case PAIR: /* for now, assume proper list (ending in NULL 'but_first') */ putchar (LEFT_PAREN); hpos++; while (obj != NULL) { if (! is_pair (obj)) error ("pp_object: not proper list"); pp_object (first (obj), col+1, hpos); obj = but_first (obj); if (obj != NULL) { hpos = 0; } } putchar (RIGHT_PAREN); break; case FUNCTION: printf ("#<function>"); break; default: error ("pp_object: not standard object"); break; } } /* write_object -- write (re-readable) printed representation of Object */ void write_object (Object obj) { pp_object (obj, 1, 0); /* indent 1 space before printing */ } tring(get_prop(obj, "pn"))); else printf ("%s", symbol(obj) -> print_name); } /* write_string -- write printed representation of STRING Object */void write_string (Object obj) { write_c_string (string (obj)); }
/* pp_object²